home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / modes / outl-mouse.el.z / outl-mouse.el
Encoding:
Text File  |  1998-05-21  |  20.7 KB  |  677 lines
  1. ;;; outl-mouse.el --- outline mode mouse commands for Emacs
  2.  
  3. ;; Copyright 1994 (C) Andy Piper <ajp@eng.cam.ac.uk>
  4. ;; Keywords: outlines, mouse
  5.  
  6. ;; This file is part of XEmacs.
  7.  
  8. ;; XEmacs is free software; you can redistribute it and/or modify it
  9. ;; under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; XEmacs is distributed in the hope that it will be useful, but
  14. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. ;; General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  20. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21. ;; Boston, MA 02111-1307, USA.
  22. ;;
  23. ;; outl-mouse.el v1.3.8:
  24. ;;
  25. ;; Defines button one to hide  blocks when clicked on outline-up-arrow
  26. ;; and expand blocks when clicked on outline-down-arrow.  Features are
  27. ;; activated   when   outline-minor-mode  or   outline-mode are turned
  28. ;; on. There is also a menu for each glyph on button 3. 
  29. ;;
  30. ;; To use put:
  31. ;;     (require 'outl-mouse)
  32. ;; in your .emacs file.
  33. ;;
  34. ;; If you use func-menu all  the time and  want outl-mouse on all  the
  35. ;; time as well then put:
  36. ;;    (setq outline-sync-with-func-menu t)
  37. ;; outlining will then be turned on when func-menu is. Note that this
  38. ;; requires a patch to func-menu 2.16 (in 19.10) to work:
  39. ;;
  40. ;RCS file: func-menu.el,v
  41. ;retrieving revision 1.1
  42. ;diff -r1.1 func-menu.el
  43. ;180a181,183
  44. ;> (defvar fume-found-function-hook nil
  45. ;>   "*Hook to call after every function match.")
  46. ;> 
  47. ;1137,1138c1140,1142
  48. ;<         (if (listp funcname)
  49. ;<             (setq funclist (cons funcname funclist)))
  50. ;---
  51. ;>         (cond ((listp funcname)
  52. ;>              (setq funclist (cons funcname funclist))
  53. ;>              (save-excursion (run-hooks 'fume-found-function-hook))))
  54. ;;
  55. ;; If you  want mac-style outlining  then set  outline-mac-style to t.
  56. ;; If you   want    the  outline   arrows on    the    left then   set
  57. ;; outline-glyphs-on-left  to t. If you  have xpm then arrows are much
  58. ;; better defined.
  59. ;;
  60. ;; This package uses func-menu to  define outline regexps if they  are
  61. ;; not already defined. You should no longer need to use out-xtra.
  62. ;;
  63. ;; You can define the package to  do something other than outlining by
  64. ;; setting outline-fold-in-function and outline-fold-out-function.
  65. ;;
  66. ;; You can define the color of outline arrows, but only in your .emacs.
  67. ;;
  68. ;; Only works in XEmacs 19.10 and onwards. 
  69. ;;
  70. ;; User definable variables.
  71. ;;
  72.  
  73. (defgroup outl-mouse nil
  74.   "Outline mouse mode commands for Emacs"
  75.   :prefix "outline-"
  76.   :group 'outlines
  77.   :group 'mouse)
  78.  
  79.  
  80. (defcustom outline-mac-style nil
  81.   "*If t then outline glyphs will be right and down arrows."
  82.   :type 'boolean
  83.   :group 'outl-mouse)
  84.  
  85. (defcustom outline-glyphs-on-left nil
  86.   "*The position of outline glyphs on a line."
  87.   :type 'boolean
  88.   :group 'outl-mouse)
  89.  
  90. (defcustom outline-glyph-colour "Gray75"
  91.   "*The colour of outlining arrows."
  92.   :type 'color
  93.   :group 'outl-mouse)
  94.  
  95. (defcustom outline-glyph-shade-colour "Gray40"
  96.   "*The shadow colour of outlining arrows."
  97.   :type 'color
  98.   :group 'outl-mouse)
  99.  
  100. (defcustom outline-glyph-lit-colour "Gray90"
  101.   "*The lit colour of outlining arrows."
  102.   :type 'color
  103.   :group 'outl-mouse)
  104.  
  105. (defvar outline-fold-in-function 'outline-fold-in
  106.   "Function to call for folding in. 
  107. The function should take an annotation argument.")
  108. (make-variable-buffer-local 'outline-fold-in-function)
  109.  
  110. (defvar outline-fold-out-function 'outline-fold-out
  111.   "Function to call for folding out. 
  112. The function should take an annotation argument.")
  113. (make-variable-buffer-local 'outline-fold-out-function)
  114.  
  115. (defcustom outline-sync-with-func-menu nil
  116.   "*If t then outline glyphs are permanently added by func-menu scans.
  117. If outline-minor-mode is  turned off then  turing it back on will have
  118. no  effect. Instead the  buffer  should be rescanned from the function
  119. menu."
  120.   :type 'boolean
  121.   :group 'outl-mouse)
  122.  
  123. (defcustom outline-move-point-after-click t
  124.   "*If t then point is moved to the current heading when clicked."
  125.   :type 'boolean
  126.   :group 'outl-mouse)
  127.  
  128. (defcustom outline-scanning-message "Adding glyphs... (%3d%%)"
  129.   "*Progress message during the scanning of the buffer.
  130. Set this to nil to inhibit progress messages."
  131.   :type 'string
  132.   :group 'outl-mouse)
  133.  
  134. ;;
  135. ;; No user definable variables beyond this point.
  136. ;;
  137.  
  138. ;; I'll bet there's a neat way to do this with specifiers -- a pity the
  139. ;; sucks so badly on it. -sb
  140. (defconst outline-up-arrow ; XEmacs
  141.   (make-glyph ; an up-arrow
  142.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  143. static char * arrow[] = {
  144. \"10 10 5 1\",
  145. \"     c none\",
  146. \".    c " outline-glyph-lit-colour "\",
  147. \"X    c " outline-glyph-shade-colour "\",
  148. \"o    c " outline-glyph-colour "\",
  149. \"O    c " outline-glyph-shade-colour "\",
  150. \"    .X    \",
  151. \"    .X    \",
  152. \"   ..XX   \",
  153. \"   ..XX   \",
  154. \"  ..ooXX  \",
  155. \"  ..ooXX  \",
  156. \" ..ooooXX \",
  157. \" ..ooooXX \",
  158. \"..OOOOOOXX\",
  159. \"OOOOOOOOOO\"};")))
  160.      ((featurep 'x)
  161.       (vector 'xbm
  162.           :data
  163.           (list 10 10
  164.             (concat "\000\000\000\000\060\000\060\000\150\000"
  165.                 "\150\000\324\000\324\000\376\001\376\001"))))
  166.      (t "^")))
  167.   "Bitmap object for outline up glyph.")
  168.  
  169. (defconst outline-up-arrow-mask ; XEmacs
  170.   (make-glyph ; an up-arrow
  171.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  172. static char * arrow[] = {
  173. \"10 10 5 1\",
  174. \"     c none\",
  175. \".    c " outline-glyph-shade-colour "\",
  176. \"X    c " outline-glyph-lit-colour "\",
  177. \"o    c " outline-glyph-colour "\",
  178. \"O    c " outline-glyph-lit-colour "\",
  179. \"    .X    \",
  180. \"    .X    \",
  181. \"   ..XX   \",
  182. \"   ..XX   \",
  183. \"  ..ooXX  \",
  184. \"  ..ooXX  \",
  185. \" ..ooooXX \",
  186. \" ..ooooXX \",
  187. \"..OOOOOOXX\",
  188. \"OOOOOOOOOO\"};")))
  189.      ((featurep 'x)
  190.       (vector 'xbm
  191.           :data 
  192.           (list 10 10
  193.             (concat "\000\000\000\000\060\000\060\000\130\000"
  194.                 "\130\000\254\000\274\000\006\001\376\001"))))
  195.      (t "+")))
  196.   "Bitmap object for outline depressed up glyph.")
  197.  
  198. (defconst outline-down-arrow ; XEmacs
  199.   (make-glyph    ; a down-arrow
  200.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  201. static char * down[] = {
  202. \"10 10 5 1\",
  203. \"     c " outline-glyph-lit-colour "\",
  204. \".    c " outline-glyph-lit-colour "\",
  205. \"X    c " outline-glyph-shade-colour "\",
  206. \"o    c none\",
  207. \"O    c " outline-glyph-colour "\",
  208. \"          \",
  209. \"..      XX\",
  210. \"o..OOOOXXo\",
  211. \"o..OOOOXXo\",
  212. \"oo..OOXXoo\",
  213. \"oo..OOXXoo\",
  214. \"ooo..XXooo\",
  215. \"ooo..XXooo\",
  216. \"oooo.Xoooo\",
  217. \"oooo.Xoooo\"};")))
  218.      ((featurep 'x)
  219.       (vector 'xbm
  220.           :data 
  221.           (list 10 10
  222.             (concat "\000\000\000\000\376\001\202\001\364\000"
  223.                 "\324\000\150\000\150\000\060\000\060\000"))))
  224.      (t "v")))
  225.   "Bitmap object for outline down glyph.")
  226.  
  227. (defconst outline-down-arrow-mask ; XEmacs
  228.   (make-glyph    ; a down-arrow
  229.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  230. static char * down[] = {
  231. \"10 10 5 1\",
  232. \"     c " outline-glyph-shade-colour "\",
  233. \".    c " outline-glyph-shade-colour "\",
  234. \"X    c " outline-glyph-lit-colour "\",
  235. \"o    c none\",
  236. \"O    c " outline-glyph-colour "\",
  237. \"          \",
  238. \"..      XX\",
  239. \"o..OOOOXXo\",
  240. \"o..OOOOXXo\",
  241. \"oo..OOXXoo\",
  242. \"oo..OOXXoo\",
  243. \"ooo..XXooo\",
  244. \"ooo..XXooo\",
  245. \"oooo.Xoooo\",
  246. \"oooo.Xoooo\"};")))
  247.      ((featurep 'x)
  248.       (vector 'xbm
  249.           :data
  250.           (list 10 10
  251.             (concat "\000\000\000\000\376\001\376\001\254\000"
  252.                 "\254\000\130\000\130\000\060\000\060\000"))))
  253.      (t "+")))
  254.   "Bitmap object for outline depressed down glyph.")
  255.  
  256. (defconst outline-right-arrow
  257.   (make-glyph    ; a right-arrow
  258.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  259. static char * right[] = {
  260. \"10 10 5 1\",
  261. \"     c " outline-glyph-lit-colour "\",
  262. \".    c " outline-glyph-lit-colour "\",
  263. \"X    c none\",
  264. \"o    c " outline-glyph-colour "\",
  265. \"O    c " outline-glyph-shade-colour "\",
  266. \" .XXXXXXXX\",
  267. \" ...XXXXXX\",
  268. \"  ....XXXX\",
  269. \"  oo....XX\",
  270. \"  oooo....\",
  271. \"  ooooOOOO\",
  272. \"  ooOOOOXX\",
  273. \"  OOOOXXXX\",
  274. \" OOOXXXXXX\",
  275. \" OXXXXXXXX\"};")))
  276.      ((featurep 'x)
  277.       (vector 'xbm
  278.           :data
  279.           (list 10 10
  280.             (concat "\000\000\006\000\032\000\142\000\232\001"
  281.                 "\352\001\172\000\036\000\006\000\000\000"))))
  282.      (t ">")))
  283.   "Bitmap object for outline right glyph.")
  284.  
  285. (defconst outline-right-arrow-mask
  286.   (make-glyph    ; a right-arrow
  287.    (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */
  288. static char * right[] = {
  289. \"10 10 5 1\",
  290. \"     c " outline-glyph-shade-colour "\",
  291. \".    c " outline-glyph-shade-colour "\",
  292. \"X    c none\",
  293. \"o    c " outline-glyph-colour "\",
  294. \"O    c " outline-glyph-lit-colour "\",
  295. \" .XXXXXXXX\",
  296. \" ...XXXXXX\",
  297. \"  ....XXXX\",
  298. \"  oo....XX\",
  299. \"  oooo....\",
  300. \"  ooooOOOO\",
  301. \"  ooOOOOXX\",
  302. \"  OOOOXXXX\",
  303. \" OOOXXXXXX\",
  304. \" OXXXXXXXX\"};")))
  305.      ((featurep 'x)
  306.       (vector 'xbm
  307.           :data
  308.           (list 10 10
  309.             (concat "\000\000\006\000\036\000\176\000\346\001"
  310.                 "\236\001\146\000\036\000\006\000\000\000"))))
  311.      (t "+")))
  312.   "Bitmap object for outline depressed right glyph.")
  313.  
  314. (defvar outline-glyph-menu
  315.   '("Outline Commands"
  316.     ["Hide all"        hide-body            t]
  317.     ["Hide all subtrees" hide-subtrees-same-level    t]
  318.     ["Hide subtree"    hide-subtree                    t]
  319. ;   ["Hide body"        hide-body                       t]
  320.     "---"
  321.     ["Show all"        show-all            t]
  322.     ["Show subtree"    show-subtree                    t]
  323.     ["Show body"        show-entry                      t]
  324.     "---"
  325.     ["Update buffer"    outline-add-glyphs        t]
  326.     ["Rescan buffer"    outline-rescan-buffer        t])
  327.   "Menu of commands for outline glyphs.")
  328.  
  329. (set-pixmap-contributes-to-line-height outline-down-arrow nil)
  330. (set-pixmap-contributes-to-line-height outline-up-arrow nil)
  331. (set-pixmap-contributes-to-line-height outline-down-arrow-mask nil)
  332. (set-pixmap-contributes-to-line-height outline-up-arrow-mask nil)
  333. (set-pixmap-contributes-to-line-height outline-right-arrow nil)
  334. (set-pixmap-contributes-to-line-height outline-right-arrow-mask nil)
  335.  
  336. (require 'annotations)
  337. (require 'advice)            ; help me doctor !
  338. (require 'outline)
  339. (require 'func-menu)            ; for those most excellent regexps.
  340.  
  341. (add-hook 'outline-mode-hook 'outline-mouse-hooks)
  342. (add-hook 'outline-minor-mode-hook 'outline-mouse-hooks)
  343. ;; I thought this was done already ...
  344. (make-variable-buffer-local 'outline-regexp)
  345. (make-variable-buffer-local 'outline-level)
  346.  
  347. (cond (outline-sync-with-func-menu
  348.        (add-hook 'fume-found-function-hook 'outline-heading-add-glyph-1)
  349.        (setq-default fume-rescan-buffer-hook '(lambda () 
  350.                         (outline-minor-mode 1)))))
  351.  
  352. (defadvice fume-set-defaults (after fume-set-defaults-ad activate)
  353.   "Advise fume-set-defaults to setup outline regexps."
  354.   (if (and (not (assq 'outline-regexp (buffer-local-variables)))
  355.        fume-function-name-regexp)
  356.       (progn
  357.     (setq outline-regexp (if (listp fume-function-name-regexp)
  358.                  (car fume-function-name-regexp)
  359.                    fume-function-name-regexp))
  360.     (setq outline-level '(lambda () 1)))))
  361.  
  362. (defadvice outline-minor-mode (after outline-mode-mouse activate)
  363.   "Advise outline-minor-mode to delete glyphs when switched off."
  364.   (if (not outline-minor-mode)
  365.       (progn 
  366.     (outline-delete-glyphs)
  367.     (show-all))))
  368.  
  369. ;; advise all outline commands so that glyphs are synced after use
  370. (defadvice show-all (after show-all-ad activate)
  371.   "Advise show-all to sync headings."
  372.   (outline-sync-visible-sub-headings-in-region (point-min) (point-max)))
  373.  
  374. (defadvice hide-subtree (after hide-subtree-ad activate)
  375.   "Advise hide-subtree to sync headings."
  376.   (outline-sync-visible-sub-headings))
  377.  
  378. (defadvice hide-entry (after hide-entry-ad activate)
  379.   "Advise hide-entry to sync headings."
  380.   (outline-sync-visible-sub-headings))
  381.  
  382. (defadvice hide-body (after hide-body-ad activate)
  383.   "Advise hide-body to sync headings."
  384.   (outline-sync-visible-sub-headings-in-region (point-min) (point-max)))
  385.  
  386. (defadvice show-subtree (after show-subtree-ad activate)
  387.   "Advise show-subtree to sync headings."
  388.   (outline-sync-visible-sub-headings))
  389.  
  390. (defadvice show-entry (after show-entry-ad activate)
  391.   "Advise shown-entry to sync headings."
  392.   (outline-sync-visible-sub-headings))
  393.  
  394. ;;;###autoload
  395. (defun outl-mouse-mode ()
  396.   "Calls outline-mode, with outl-mouse extensions"
  397.   (interactive)
  398.   (outline-mode))
  399.     
  400. ;;;###autoload
  401. (defun outl-mouse-minor-mode (&optional arg)
  402.   "Toggles outline-minor-mode, with outl-mouse extensions"
  403.   (interactive "P")
  404.   (outline-minor-mode arg))
  405.  
  406. (defun hide-subtrees-same-level ()
  407.   "Hide all subtrees below the current level."
  408.   (interactive)
  409.   (save-excursion
  410.     (while (progn
  411.          (hide-subtree)
  412.                (condition-case nil
  413.          (progn
  414.            (outline-forward-same-level 1)
  415.            t)
  416.            (error nil))))))
  417.  
  418. (defun outline-mouse-hooks ()
  419.   "Hook for installing outlining with the mouse."
  420.   ;; use function menu regexps if not set
  421.   (fume-set-defaults)
  422.   ;; only add glyphs when we're not synced.
  423.   (if (not outline-sync-with-func-menu) (outline-add-glyphs))
  424.   ;; add C-a to local keymap
  425.   (let ((outline (cond ((keymapp (lookup-key (current-local-map)
  426.                          outline-minor-mode-prefix))
  427.             (lookup-key (current-local-map)
  428.                     outline-minor-mode-prefix))
  429.                (t
  430.             (define-key (current-local-map)
  431.               outline-minor-mode-prefix (make-sparse-keymap))
  432.             (lookup-key (current-local-map) 
  433.                     outline-minor-mode-prefix)))))
  434.     (define-key outline "\C-a" 'outline-heading-add-glyph)
  435.     (define-key outline-mode-map "\C-c\C-a" 'outline-heading-add-glyph)))
  436.  
  437. (defun outline-add-glyphs ()
  438.   "Add annotations and glyphs to all heading lines that don't have them."
  439.   (interactive)
  440.   (save-excursion
  441.     (and outline-scanning-message (display-message
  442.                    'progress
  443.                    (format outline-scanning-message 0)))
  444.     (goto-char (point-min))
  445.     (if (not (outline-on-heading-p)) (outline-next-visible-heading-safe))
  446.     (while 
  447.     (progn
  448.       (outline-heading-add-glyph-1)
  449.       (and outline-scanning-message 
  450.            (display-message
  451.         'progress
  452.         (format outline-scanning-message (fume-relative-position))))
  453.       (outline-next-visible-heading-safe)))
  454.     (and outline-scanning-message 
  455.      (display-message
  456.       'progress
  457.       (format "%s done" (format outline-scanning-message 100))))))
  458.  
  459. (defun outline-delete-glyphs ()
  460.   "Remove annotations and glyphs from heading lines."
  461.   (save-excursion
  462.     (mapcar 'outline-heading-delete-glyph (annotation-list))))
  463.  
  464. (defun outline-rescan-buffer ()
  465.   "Remove and insert all annotations."
  466.   (interactive)
  467.   (outline-delete-glyphs)
  468.   (outline-add-glyphs)
  469.   (save-excursion
  470.     (outline-sync-visible-sub-headings-in-region (point-min) (point-max))))
  471.  
  472. (defun outline-heading-delete-glyph (ext)
  473.   "Delete annotation and glyph from a heading with annotation EXT."
  474.   (if (and 
  475.        (progn
  476.      (goto-char (extent-start-position ext))
  477.      (beginning-of-line)
  478.      (outline-on-heading-p))
  479.        (extent-property ext 'outline))
  480.       (delete-annotation ext))
  481.   nil)
  482.  
  483. (defun outline-heading-add-glyph ()
  484.   "Interactive version of outline-heading-add-glyph-1."
  485.   (interactive)
  486.   (save-excursion
  487.     (outline-heading-add-glyph-1)))
  488.  
  489. (defun outline-heading-add-glyph-1 ()
  490.   "Add glyph to the end of heading line which point is on.
  491.  Returns nil if point is not on a heading or glyph already exists."
  492.   (if (or (not (outline-on-heading-p))
  493.       (outline-heading-has-glyph-p)
  494.       (save-excursion (forward-line) (outline-on-heading-p)))
  495.       nil
  496.     (outline-back-to-heading)
  497.     (let ((anot2 
  498.        (make-annotation (if outline-mac-style 
  499.                 outline-right-arrow
  500.                   outline-down-arrow)
  501.                 (save-excursion (if outline-glyphs-on-left nil
  502.                           (outline-end-of-heading))
  503.                         (point))
  504.                 'text nil t 
  505.                 (if outline-mac-style
  506.                 outline-right-arrow-mask
  507.                   outline-down-arrow-mask)))
  508.       (anot1 
  509.        (make-annotation (if outline-mac-style
  510.                 outline-down-arrow
  511.                   outline-up-arrow)
  512.                 (save-excursion (if outline-glyphs-on-left nil
  513.                           (outline-end-of-heading))
  514.                         (point))
  515.                 'text nil t 
  516.                 (if outline-mac-style
  517.                 outline-down-arrow-mask
  518.                   outline-up-arrow-mask))))
  519.       ;; we cunningly make the annotation data point to its twin.
  520.       (set-annotation-data anot1 anot2)
  521.       (set-extent-property anot1 'outline 'up)
  522.       (set-annotation-action anot1 'outline-up-click)
  523.       (set-annotation-menu anot1 outline-glyph-menu)
  524.       (set-extent-priority anot1 1)
  525.       (set-annotation-data anot2 anot1)
  526.       (set-extent-property anot2 'outline 'down)
  527.       (set-annotation-menu anot2 outline-glyph-menu)
  528.       (set-annotation-action anot2 'outline-down-click)
  529.       (annotation-hide anot2))
  530.     t))
  531.  
  532. (defun outline-heading-has-glyph-p ()
  533.   "Return t if heading has an outline glyph."
  534.   (catch 'found
  535.     (mapcar
  536.      '(lambda(a)
  537.     (if (extent-property a 'outline)
  538.         (throw 'found t)))
  539.      (annotations-in-region (save-excursion (outline-back-to-heading) (point))
  540.                 (save-excursion (outline-end-of-heading) 
  541.                         (+ 1 (point)))
  542.                 (current-buffer)))
  543.     nil))
  544.  
  545. (defun outline-sync-visible-sub-headings-in-region (pmin pmax)
  546.   "Make sure all anotations on headings in region PMIN PMAX are 
  547. displayed correctly."
  548.   (mapcar '(lambda (x) 
  549.          (goto-char (extent-start-position x))
  550.          (beginning-of-line)
  551.          (cond ((and (eq (extent-property x 'outline) 'down)
  552.              ;; skip things we can't see
  553.              (not (eq (preceding-char) ?\^M)))
  554.             (if (outline-more-to-hide)
  555.             ;; reveal my twin
  556.             (annotation-reveal (annotation-data x))
  557.               (annotation-hide (annotation-data x)))
  558.             (if (not (outline-hidden-p))
  559.             ;; hide my self
  560.             (annotation-hide x)
  561.               (annotation-reveal x)))))
  562.       (annotations-in-region pmin pmax (current-buffer))))
  563.  
  564. (defun outline-sync-visible-sub-headings ()
  565.   "Make sure all anotations on sub-headings below the one point is on are 
  566. displayed correctly."
  567.   (outline-sync-visible-sub-headings-in-region 
  568.    (point) 
  569.    (progn (outline-end-of-subtree) (point))))
  570.  
  571. (defun outline-fold-out (annotation)
  572.   "Fold out the current heading."
  573.   (beginning-of-line)
  574. ;  (if (not (equal (condition-case nil
  575. ;              (save-excursion (outline-next-visible-heading 1)
  576. ;                      (point))
  577. ;            (error nil))
  578. ;          (save-excursion (outline-next-heading) 
  579. ;                  (if (eobp) nil (point)))))
  580.   (if (save-excursion (outline-next-heading) 
  581.               (eq (preceding-char) ?\^M))
  582.       (progn 
  583.     (save-excursion (show-children))
  584.     (outline-sync-visible-sub-headings))
  585.     ;; mess with single entry
  586.     (if (outline-hidden-p) 
  587.     (progn 
  588.       (save-excursion (show-entry))
  589.       ;; reveal my twin and hide me
  590.       (annotation-hide annotation)
  591.       (annotation-reveal (annotation-data annotation))))))
  592.  
  593. (defun outline-fold-in (annotation)
  594.   "Fold in the current heading."
  595.   (beginning-of-line)
  596.   ;; mess with single entries
  597.   (if (not (outline-hidden-p))
  598.       (progn
  599.     (save-excursion (hide-entry))
  600.     (if (not (outline-more-to-hide))
  601.         (annotation-hide annotation))
  602.     (annotation-reveal (annotation-data annotation)))
  603.     ;; otherwise look for more leaves
  604.     (save-excursion 
  605.       (if (outline-more-to-hide t)
  606.       (hide-subtree)
  607.     (hide-leaves)))
  608.     ;; sync everything
  609.     (outline-sync-visible-sub-headings)))
  610.  
  611. (defun outline-more-to-hide (&optional arg)
  612.   "Return t if there are more visible sub-headings or text.
  613. With ARG return t only if visible sub-headings have no visible text."
  614.   (if (not (outline-hidden-p))
  615.       (if arg nil t)
  616.     (save-excursion
  617.       (and (< (funcall outline-level) (condition-case nil
  618.                       (progn 
  619.                         (outline-next-visible-heading 1)
  620.                         (funcall outline-level))
  621.                     (error 0)))
  622.        (if (and (not (outline-hidden-p)) arg)
  623.            nil t)))))
  624.  
  625. (defun outline-hidden-p ()
  626.   "Return t if point is on the header of a hidden subtree."
  627.   (save-excursion
  628.     (let ((end-of-entry (save-excursion (outline-next-heading))))
  629.       ;; Make sure that the end of the entry really exists.
  630.       (if (not end-of-entry)
  631.       (setq end-of-entry (point-max)))
  632.       (outline-back-to-heading)
  633.       ;; If there are ANY ^M's, the entry is hidden.
  634.       (search-forward "\^M" end-of-entry t))))
  635.  
  636. (defun outline-next-visible-heading-safe ()
  637.   "Safely go to the next visible heading. 
  638. nil is returned if there is none."
  639.   (condition-case nil
  640.       (progn
  641.     (outline-next-visible-heading 1)
  642.     t)
  643.     (error nil)))
  644.  
  645. (defun outline-up-click (data ev)
  646.   "Annotation action for clicking on an up arrow.
  647. DATA is the annotation data. EV is the mouse click event."
  648.   (save-excursion
  649.     (goto-char (extent-end-position (event-glyph-extent ev)))
  650.     (funcall outline-fold-in-function (event-glyph-extent ev)))
  651.   (if outline-move-point-after-click
  652.       (progn
  653.     (goto-char (extent-end-position (event-glyph-extent ev)))
  654.     (beginning-of-line))))
  655. ; This line demonstrates a bug in redisplay
  656. (defun outline-down-click (data ev)
  657.   "Annotation action for clicking on a down arrow.
  658. DATA is the annotation data. EV is the mouse click event."
  659.   (save-excursion
  660.     (goto-char (extent-end-position (event-glyph-extent ev)))
  661.     (funcall outline-fold-out-function (event-glyph-extent ev)))
  662.   (if outline-move-point-after-click
  663.       (progn
  664.     (goto-char (extent-end-position (event-glyph-extent ev)))
  665.     (beginning-of-line))))
  666.  
  667.  
  668. (provide 'outl-mouse)
  669. (provide 'outln-18)            ; fool auctex - outline is ok now.
  670.  
  671. ;; Local Variables:
  672. ;; outline-regexp: ";;; \\|(def.."
  673. ;; End:
  674.  
  675.  
  676.  
  677.